Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/linectrl.zip/LINECTRL.PAS

Pascal/Delphi Source File | 1993-01-04 | 6KB | 270 lines

PROGRAM LineCtrl;

{$B-,D+,R-,S-,V-}

USES DOS, CRT;

CONST
  Bell = #7;

TYPE
  line = STRING[255];

VAR
  Option      : integer;
  LineRead    : line;
  InFile      : TEXT;
  OutFile     : TEXT;
  InFileName  : line;
  OutFileName : line;
  Version     : line;
  Buf1        : Array[1..16384] of Char;
  Buf2        : Array[1..16384] of Char;

{
┌────────────────────────────────────────────────────┐
│ PROCEDURE Error_Message                            │
└────────────────────────────────────────────────────┘
}

PROCEDURE Error_Message (message : string);

BEGIN
  WRITELN (Bell,message);                      { ding bell & write message }
  HALT;
END;

{
┌────────────────────────────────────────────────────┐
│ PROCEDURE Usage                                    │
└────────────────────────────────────────────────────┘
}

PROCEDURE Usage;

CONST
  NL = #13#10;

BEGIN
  WRITELN (Bell,
'A text file utility that removes consecutive blank lines exceeding a user',NL,
'definable number; default is 1 blank line at most.  ',NL,
'',NL,
'USAGE:     LINECTRL [infile] [outfile] {/numlines}',NL,
'',NL,
'"numlines" is the maximum number of consecutive blank lines to keep in the',NL,
'text file.  0 is acceptable (i.e., no blank lines).',NL);

  Halt;
END;

{
┌────────────────────────────────────────────────────┐
│ PROCEDURE Read_Params                              │
└────────────────────────────────────────────────────┘
}

PROCEDURE Read_Params (VAR param_option : integer; VAR InFileNameV  : line;
                                                   VAR OutFileNameV : line);

VAR
  param : string;
  code  : integer;

BEGIN
  IF (ParamCount IN [2,3]) THEN
    BEGIN
      InFileNameV  := ParamStr(1);
      OutFileNameV := ParamStr(2);
      IF ParamStr(3) = '' THEN
        BEGIN
          param_option := 1;
          EXIT;
        END;
                                             { implied ELSE routine        }
      param        := ParamStr(3);           { check number of blank lines }
      IF POS ('/',param) = 1 THEN            { to keep                     }
        BEGIN
          DELETE (param,1,1);
          VAL (param, param_option, code);
          IF code <> 0 THEN
            Error_Message ('Error -- Input invalid');
        END
      ELSE
        Error_Message ('Error -- Illegal parameter');
    END
  ELSE
    Usage;
END;

{
┌────────────────────────────────────────────────────┐
│ PROCEDURE OPEN_INFILE                              │
└────────────────────────────────────────────────────┘
}

PROCEDURE Open_InFile (InFileNameV : line; VAR InFileV : TEXT);

VAR
  FileAttr : word;

BEGIN
{$I-}

  ASSIGN (InFileV,InFileNameV);
  IF IOresult <> 0 THEN Error_Message ('Error -- cannot assign filename');

  GetFAttr (InFileV, FileAttr);
  IF (FileAttr AND Directory) <> 0 THEN
    Error_Message ('Error -- input file does not exist in current directory');

  RESET (InFileV);
  IF IOresult <> 0 THEN Error_Message ('Error -- cannot open input file');

  SETTEXTBUF (InFileV, Buf1);

{$I+}
END;

{
┌────────────────────────────────────────────────────┐
│ PROCEDURE OPEN_OUTFILE                             │
└────────────────────────────────────────────────────┘
}

PROCEDURE Open_OutFile (OutFileNameV : line; VAR OutFileV : TEXT);

BEGIN
{$I-}

  ASSIGN (OutFileV,OutFileNameV);
  IF IOresult <> 0 THEN Error_Message ('Error -- cannot assign filename');

  REWRITE (OutFileV);
  IF IOresult <> 0 THEN Error_Message ('Error -- cannot open output file');

  SETTEXTBUF (OutFileV, Buf2);

{$I+}
END;

{
┌────────────────────────────────────────────────────┐
│ PROCEDURE CLOSE_FILES                              │
└────────────────────────────────────────────────────┘
}

PROCEDURE Close_Files (VAR InFileV : TEXT; VAR OutFileV : TEXT);

BEGIN
  CLOSE (InFileV);
  CLOSE (OutFileV);
  WRITELN (Bell);                               { ding bell }
END;

{
┌────────────────────────────────────────────────────┐
│ FUNCTION ALLSPACES                                 │
└────────────────────────────────────────────────────┘
}

FUNCTION Allspaces (str : LINE) : INTEGER;

VAR
  i, cnt : INTEGER;

BEGIN
  i   := 1;
  cnt := LENGTH(str);
  IF cnt = 0 THEN
    Allspaces := 0
  ELSE
    BEGIN
      WHILE (str[i] = ' ') AND (i <= cnt) DO
        INC(i);
      IF (i - 1) = cnt THEN
        Allspaces := 1
      ELSE
       Allspaces := -1;
    END;
END;

{
┌────────────────────────────────────────────────────┐
│ FUNCTION I_lesser                                  │
└────────────────────────────────────────────────────┘
}

FUNCTION I_lesser (a,b : LONGINT) : LONGINT;

BEGIN
  IF a < b THEN
    I_lesser := a
  ELSE
    I_lesser := b;
END;

{
┌────────────────────────────────────────────────────┐
│ PROCEDURE PROCESS_INFILE                           │
└────────────────────────────────────────────────────┘
}

PROCEDURE Process_InFile (NumLines : integer;
                          VAR InFileV : TEXT; VAR OutFileV : TEXT);

VAR
  Count    : integer;
  i        : longint;

BEGIN
  Count    := 0;

  WHILE NOT EOF (InFileV) DO
    BEGIN
      READLN (InFileV,LineRead);

      CASE ALLSPACES (LineRead) OF
        -1:  BEGIN
               IF Count > 0 THEN
                 BEGIN
                   FOR i:= 1 TO I_Lesser (Count, NumLines) DO
                     WRITELN (OutFile);
                   Count := 0;
                 END;
               WRITELN (OutFileV, LineRead);
             END;
        0,1: INC (Count);
      END; {case}

    END; { while#1 }

  FLUSH (OutFileV);                            { ensure all lines written }
END;

{
┌────────────────────────────────────────────────────┐
│ MAIN PROGRAM                                       │
└────────────────────────────────────────────────────┘
}

BEGIN

  Version := 'Version 1.1, 6-29-88 -- Public Domain by John Land';

  CLRSCR;

  Read_Params (Option, InFileName, OutFileName);

  Open_InFile (InFileName, InFile);

  Open_OutFile (OutFileName, OutFile);

  WRITELN ('PROCESSING ',InFileName, ' INTO ', OutFileName);

  Process_InFile (Option, InFile, OutFile);

  Close_Files (InFile, OutFile);

END.